home *** CD-ROM | disk | FTP | other *** search
/ Workbench Add-On / Workbench Add-On - Volume 1.iso / Dev / Oberon / source / OC / OCP.mod < prev    next >
Text File  |  1995-06-29  |  37KB  |  1,110 lines
  1. (*************************************************************************
  2.  
  3.      $RCSfile: OCP.mod $
  4.   Description: Code selection for standard procedures
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 5.16 $
  8.       $Author: fjc $
  9.         $Date: 1995/06/29 19:10:59 $
  10.  
  11.   Copyright © 1990-1993, ETH Zuerich
  12.   Copyright © 1993-1995, Frank Copeland
  13.   This module forms part of the OC program
  14.   See OC.doc for conditions of use and distribution
  15.  
  16.   Log entries are at the end of the file.
  17.  
  18. *************************************************************************)
  19.  
  20. <* STANDARD- *> <* MAIN- *> <*$ LongVars+ *>
  21.  
  22. MODULE OCP;
  23.  
  24. IMPORT SYS := SYSTEM, OCM, OCS, OCT, OCC, OCI, OCE;
  25.  
  26.  
  27. (* --- Local declarations ----------------------------------------------- *)
  28.  
  29. CONST
  30.  
  31.   (* object modes *)
  32.   Var = OCM.Var; VarX = OCM.VarX; Ind = OCM.Ind; IndX = OCM.IndX;
  33.   RegI = OCM.RegI; RegX = OCM.RegX; Lab = OCM.Lab; LabI = OCM.LabI;
  34.   Con = OCM.Con; Push = OCM.Push; Pop = OCM.Pop; Coc = OCM.Coc;
  35.   Reg = OCM.Reg; Fld = OCM.Fld; Typ = OCM.Typ; Abs = OCM.Abs;
  36.   XProc = OCM.XProc; LProc = OCM.LProc;
  37.  
  38.   (* System flags *)
  39.  
  40.   OberonFlag = OCM.OberonFlag; M2Flag = OCM.M2Flag; CFlag = OCM.CFlag;
  41.   BCPLFlag = OCM.BCPLFlag; AsmFlag = OCM.AsmFlag;
  42.  
  43.   (* structure forms *)
  44.   Undef = OCT.Undef; Byte = OCT.Byte; Bool = OCT.Bool; Char = OCT.Char;
  45.   SInt = OCT.SInt; Int = OCT.Int; LInt = OCT.LInt; Real = OCT.Real;
  46.   LReal = OCT.LReal; Set = OCT.Set; String = OCT.String;
  47.   NilTyp = OCT.NilTyp; NoTyp = OCT.NoTyp; Pointer = OCT.Pointer;
  48.   ProcTyp = OCT.ProcTyp; Array = OCT.Array; DynArr = OCT.DynArr;
  49.   Record = OCT.Record; PtrTyp = OCT.PtrTyp; AdrTyp = OCT.AdrTyp;
  50.   BPtrTyp = OCT.BPtrTyp; BSet = OCT.BSet; WSet = OCT.WSet; Word = OCT.Word;
  51.   Longword = OCT.Longword; TagTyp = OCT.TagTyp;
  52.  
  53.   intSet   = {SInt, Int, LInt};
  54.   realSet  = {Real, LReal};
  55.   setSet   = {BSet, WSet, Set};
  56.   ptrSet   = {Pointer, PtrTyp, AdrTyp, BPtrTyp};
  57.   uptrSet  = {AdrTyp, BPtrTyp};
  58.   allSet   = {0 .. 31};
  59.   adrSet   = {LInt, Pointer, PtrTyp, AdrTyp, Longword};
  60.   bitOpSet = intSet + setSet + {Byte, Char, Word, Longword};
  61.   putSet   =
  62.     {Undef .. LInt, Word, Longword, ProcTyp} + setSet + ptrSet + realSet;
  63.  
  64.   (* CPU Registers *)
  65.  
  66.   D0 = 0; D1 = 1; D7 = 7; A0 = 8; A1 = 9; A3 = 11; A4 = 12; A5 = 13;
  67.   A6 = 14; A7 = 15; BP = A4; FP = A5; SP = A7;
  68.   DataRegs = {D0 .. D7};
  69.   AdrRegs = {A0 .. A7};
  70.  
  71.   (* Data sizes *)
  72.  
  73.   B = 1; W = 2; L = 4;
  74.  
  75. (* --- Procedure declarations ------------------------------------------- *)
  76.  
  77. (*------------------------------------*)
  78. PROCEDURE CheckCleanupProc (VAR x : OCT.Item);
  79.  
  80.   VAR par : OCT.Object; typ : OCT.Struct;
  81.  
  82. BEGIN (* CheckCleanupProc *)
  83.   IF (x.mode = XProc) OR (x.typ.form = ProcTyp) THEN
  84.     IF x.mode = XProc THEN par := x.obj.link; typ := x.typ
  85.     ELSE par := x.typ.link; typ := x.typ.BaseTyp;
  86.     END;
  87.     IF OCT.IsParam (par) THEN OCS.Mark (117) END;
  88.     IF typ # OCT.notyp THEN OCS.Mark (301) END
  89.   ELSE
  90.     OCS.Mark (300)
  91.   END
  92. END CheckCleanupProc;
  93.  
  94. (*----------------------------%-------*)
  95. PROCEDURE NeedsTag (typ : OCT.Struct) : BOOLEAN;
  96.  
  97.   VAR fld : OCT.Object;
  98.  
  99. BEGIN (* NeedsTag *)
  100.   IF (typ.form IN {Pointer, Record}) & (typ.sysflg = OberonFlag) THEN
  101.     RETURN TRUE
  102.   ELSIF typ.form IN {Array, DynArr} THEN
  103.     RETURN NeedsTag (typ.BaseTyp)
  104.   END;
  105.   RETURN FALSE
  106. END NeedsTag;
  107.  
  108. (*------------------------------------*)
  109. PROCEDURE SaveRegs * ( fctno : INTEGER; VAR R : OCC.RegState );
  110.  
  111.   VAR x : OCT.Item;
  112.  
  113. BEGIN (* SaveRegs *)
  114.   CASE fctno OF
  115.     OCT.pDISPOSE, OCT.pMOVE :
  116.       x.mode := Undef; OCC.SaveRegisters (R, x, OCC.AllRegs)
  117.     |
  118.   ELSE
  119.     R.regs := {}
  120.   END
  121. END SaveRegs;
  122.  
  123. (*------------------------------------*)
  124. PROCEDURE StPar1 *
  125.   ( VAR x : OCT.Item; fctno : INTEGER; VAR R : OCC.RegState );
  126.  
  127.   VAR f, f1 : INTEGER; y, z, r0, r1 : OCT.Item;
  128.       size : LONGINT; par : OCT.Object;
  129.       typ : OCT.Struct; desc : OCT.Desc; s : SET;
  130.  
  131.   (*------------------------------------*)
  132.   PROCEDURE GetTag (VAR x : OCT.Item);
  133.  
  134.     VAR y, z : OCT.Item;
  135.  
  136.   BEGIN (* GetTag *)
  137.     IF OCC.InAdrReg (x.obj) THEN
  138.       OCC.GetAReg (x, x.obj)
  139.     ELSE
  140.       y := x; y.obj := NIL; y.typ := OCT.ptrtyp; OCC.GetAReg (x, x.obj);
  141.       IF OCS.pragma [OCS.nilChk] THEN
  142.         OCC.GetDReg (z, NIL); OCC.Move (L, y, z);      (* MOVE.L  x,Dn   *)
  143.         OCC.TrapCC (OCC.NilCheck, OCC.EQ);
  144.         OCC.Move (L, z, x); OCI.Unload (z)             (* MOVEA.L Dn, An *)
  145.       ELSE
  146.         OCC.Move (L, y, x);                            (* MOVEA.L x, An  *)
  147.       END;
  148.       OCI.Unload (y)
  149.     END;
  150.     x.mode := RegI; x.a1 := -4; x.a2 := 0; x.obj := OCC.wasderef;
  151.     x.rdOnly := FALSE;
  152.   END GetTag;
  153.  
  154. BEGIN (* StPar1 *)
  155.   f := x.typ.form; size := x.typ.size;
  156.   CASE fctno OF
  157.     OCT.pABS :
  158.       IF f IN intSet THEN
  159.         IF x.mode = Con THEN
  160.           x.a0 := ABS (x.a0)
  161.         ELSE
  162.           OCI.Load (x);                                (*    MOVE.z  x,Dn *)
  163.           OCC.PutF1 (OCC.TST, size, x);                (*    TST.z   Dn   *)
  164.           OCC.PutWord (6A02H);                         (*    BPL     1$   *)
  165.           OCC.PutF1 (OCC.NEG, size, x)                 (*    NEG.z   Dn   *)
  166.         END
  167.       ELSIF f IN realSet THEN
  168.         OCC.LoadRegParams1 (R, x);
  169.         OCC.CallKernel (OCC.kSPAbs);
  170.         OCC.RestoreRegisters (R, x)
  171.       ELSE
  172.         OCS.Mark (111)
  173.       END
  174.     |
  175.     OCT.pCAP :
  176.       IF (f = String) & (x.a1 <= 2) THEN
  177.         x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  178.       END;
  179.       IF f = Char THEN
  180.         IF x.mode = Con THEN
  181.           x.a0 := ORD (CAP (CHR (x.a0)))
  182.         ELSE
  183.           y.mode := Con; y.typ := OCT.chartyp;
  184.           OCI.Load (x);                                (*    MOVE x,Dn    *)
  185.           y.a0 := ORD ("a");
  186.           OCC.PutF6 (OCC.CMPI, B, y, x);               (*    CMPI "a", Dn *)
  187.           OCC.PutWord (6510H);                         (*    BCS 1$       *)
  188.           y.a0 := ORD ("z");
  189.           OCC.PutF6 (OCC.CMPI, B, y, x);               (*    CMPI "z", Dn *)
  190.           OCC.PutWord (6306H);                         (*    BLS 0$       *)
  191.           y.a0 := 0E0H; OCC.PutF6 (OCC.CMPI, B, y, x); (*    CMPI 0E0X,Dn *)
  192.           OCC.PutWord (6504H);                         (*    BCS 1$       *)
  193.           y.a0 := 0DFH; OCC.PutF6 (OCC.ANDI, B, y, x); (* 0$ ANDI 0DFH,Dn *)
  194.         END                                            (* 1$              *)
  195.       ELSE
  196.         OCS.Mark (111); x.typ := OCT.chartyp
  197.       END
  198.     |
  199.     OCT.pCHR :
  200.       IF ~(f IN {Undef, Byte, SInt, Int, LInt}) THEN OCS.Mark (111) END;
  201.       IF ~(f IN {Byte, SInt}) & (x.mode # Con) THEN OCI.Load (x) END;
  202.       x.typ := OCT.chartyp
  203.     |
  204.     OCT.pENTIER :
  205.       IF f IN realSet THEN
  206.         OCC.LoadRegParams1 (R, x);
  207.         OCC.CallKernel (OCC.kSPFix);
  208.         OCC.RestoreRegisters (R, x)
  209.       ELSE OCS.Mark (111)
  210.       END;
  211.       x.typ := OCT.linttyp;
  212.     |
  213.     OCT.pHALT :
  214.       IF (f IN intSet) & (x.mode = Con) THEN
  215.         r0.mode := Reg; r0.a0 := D0;
  216.         OCC.Move (L, x, r0);                     (* MOVE.L x,D0          *)
  217.         y.mode := Con; y.a0 := 0; y.typ := OCT.stringtyp;
  218.         y.label := OCT.ConstLabel;
  219.         OCC.PutF2 (OCC.LEA, y, A0);              (* LEA    ModuleName,A0 *)
  220.         y.a0 := (OCS.line * 10000H) + OCS.col; y.typ := OCT.linttyp;
  221.         r1.mode := Reg; r1.a0 := D1;
  222.         OCC.Move (L, y, r1);                     (* MOVE.L pos,D1        *)
  223.         OCC.CallKernel (OCC.kHalt)               (* JSR    Kernel_Halt   *)
  224.       ELSE
  225.         OCS.Mark (17)
  226.       END;
  227.       x.typ := OCT.notyp
  228.     |
  229.     OCT.pLONG :
  230.       IF (f = String) & (x.a1 <= 2) THEN
  231.         x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  232.       END;
  233.       IF f = SInt THEN OCE.ConvertInts (x, OCT.inttyp)
  234.       ELSIF f = Int THEN OCE.ConvertInts (x, OCT.linttyp)
  235.       ELSIF f = BSet THEN
  236.         IF OCS.option [OCS.standard] THEN OCS.Mark (915) END;
  237.         IF x.mode # Con THEN
  238.           y := x; x.mode := Con; x.a0 := 0; x.typ := OCT.wsettyp;
  239.           OCI.Load (x); OCC.Move (B, y, x)
  240.         END;
  241.         x.typ := OCT.wsettyp
  242.       ELSIF f = WSet THEN
  243.         IF OCS.option [OCS.standard] THEN OCS.Mark (915) END;
  244.         IF x.mode # Con THEN
  245.           y := x; x.mode := Con; x.a0 := 0; x.typ := OCT.settyp;
  246.           OCI.Load (x); OCC.Move (W, y, x)
  247.         END;
  248.         x.typ := OCT.settyp
  249.       ELSIF f = Real THEN
  250.         x.typ := OCT.lrltyp
  251.       ELSIF f = Char THEN
  252.         IF x.mode # Con THEN
  253.           y := x; x.mode := Con; x.a0 := 0; x.typ := OCT.linttyp;
  254.           OCI.Load (x); OCC.Move (B, y, x)
  255.         END;
  256.         x.typ := OCT.linttyp
  257.       ELSE
  258.         OCS.Mark (111)
  259.       END
  260.     |
  261.     OCT.pMAX :
  262.       IF x.mode = Typ THEN
  263.         x.mode := Con;
  264.         CASE f OF
  265.           Bool  : x.a0 := OCM.MaxBool                      |
  266.           Char  : x.a0 := OCM.MaxChar                      |
  267.           SInt  : x.a0 := OCM.MaxSInt                      |
  268.           Int   : x.a0 := OCM.MaxInt                       |
  269.           LInt  : x.a0 := OCM.MaxLInt                      |
  270.           Real  : x.a0 := 07F7FFFFFH                       |
  271.           LReal : x.a0 := 07F7FFFFFH                       |
  272.           BSet  : x.a0 := OCM.MaxBSet; x.typ := OCT.inttyp |
  273.           WSet  : x.a0 := OCM.MaxWSet; x.typ := OCT.inttyp |
  274.           Set   : x.a0 := OCM.MaxSet; x.typ := OCT.inttyp  |
  275.         ELSE
  276.           OCS.Mark (111)
  277.         END; (* CASE f *)
  278.       ELSE
  279.         OCS.Mark (110)
  280.       END
  281.     |
  282.     OCT.pMIN :
  283.       IF x.mode = Typ THEN
  284.         x.mode := Con;
  285.         CASE f OF
  286.           Bool  : x.a0 := OCM.MinBool                               |
  287.           Char  : x.a0 := OCM.MinChar                               |
  288.           SInt  : x.a0 := OCM.MinSInt                               |
  289.           Int   : x.a0 := OCM.MinInt                                |
  290.           LInt  : x.a0 := OCM.MinLInt                               |
  291.           Real  : x.a0 := 0FF7FFFFFH                                |
  292.           LReal : x.a0 := 0FF7FFFFFH                                |
  293.           BSet, WSet, Set : x.a0 := OCM.MinSet; x.typ := OCT.inttyp |
  294.         ELSE
  295.           OCS.Mark (111)
  296.         END; (* CASE f *)
  297.       ELSE
  298.         OCS.Mark (110)
  299.       END
  300.     |
  301.     OCT.pNEW :
  302.       IF (f = Pointer) & (x.mode # Con) THEN
  303.         IF x.rdOnly THEN OCS.Mark (324) END;
  304.         typ := x.typ; f1 := typ.sysflg;
  305.         typ := typ.BaseTyp; f := typ.form;
  306.         IF f = DynArr THEN
  307.           OCI.UnloadDesc (x);
  308.           desc := x.desc; IF desc = NIL THEN NEW (desc) END;
  309.           desc.lev := x.lev; desc.mode := x.mode; desc.a0 := x.a0;
  310.           desc.a1 := x.a1; desc.a2 := x.a2; x.desc := desc;
  311.         END;
  312.         z.mode := Undef; OCC.SaveRegisters (R, z, OCC.AllRegs);
  313.         IF (f = DynArr) & (x.mode IN {VarX, IndX, RegI, RegX}) THEN
  314.           IF x.mode IN {RegI, RegX} THEN OCC.ReserveReg (x.a0, NIL) END;
  315.           IF x.mode # RegI THEN OCC.ReserveReg (x.a2, NIL) END
  316.         END;
  317.         z.mode := Push; z.a0 := SP;
  318.         IF (f1 = OberonFlag) & NeedsTag (typ) THEN
  319.           IF f = DynArr THEN
  320.             WHILE typ.form = DynArr DO typ := typ.BaseTyp END;
  321.             WHILE typ.form = Array DO typ := typ.BaseTyp END;
  322.           ELSIF f = Array THEN
  323.             WHILE typ.form = Array DO typ := typ.BaseTyp END;
  324.           END;
  325.           y.mode := Con; y.a0 := 0; y.typ := OCT.tagtyp;
  326.           y.label := typ.label;
  327.           OCC.PutF3 (OCC.PEA, y);                 (* PEA #tag            *)
  328.           IF f = Array THEN
  329.             y.mode := Con; y.a0 := typ.size; y.typ := OCT.linttyp;
  330.             OCC.Move (L, y, z);                   (* MOVE.L #size,-(A7)  *)
  331.           END
  332.         ELSIF f # DynArr THEN
  333.           y.mode := Con; y.a0 := typ.size; y.typ := OCT.linttyp;
  334.           OCC.Move (L, y, z);                     (* MOVE.L #size, -(A7) *)
  335.         END
  336.       ELSE OCS.Mark (111)
  337.       END
  338.     |
  339.     OCT.pODD :
  340.       IF f IN intSet THEN
  341.         y.mode := Con; y.a0 := 0; y.typ := OCT.inttyp;
  342.         IF f = SInt THEN OCC.Bit (OCC.BTST, y, x);
  343.         ELSE OCI.Load (x); OCC.Bit (OCC.BTST, y, x); OCI.Unload (x)
  344.         END;
  345.       ELSE
  346.         OCS.Mark (111)
  347.       END;
  348.       OCE.setCC (x, OCC.NE)
  349.     |
  350.     OCT.pORD :
  351.       IF (f = String) & (x.a1 <= 2) THEN
  352.         x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  353.       END;
  354.       IF (f = Char) OR (f = Byte) THEN
  355.         IF x.mode # Con THEN
  356.           y := x; x.mode := Con; x.a0 := 0; x.typ := OCT.inttyp;
  357.           OCI.Load (x); OCC.Move (B, y, x)
  358.         END
  359.       ELSE
  360.         OCS.Mark (111)
  361.       END;
  362.       x.typ := OCT.inttyp
  363.     |
  364.     OCT.pSHORT :
  365.       IF f = LInt THEN
  366.         IF x.mode = Con THEN
  367.           OCE.SetIntType (x); IF x.typ.form = LInt THEN OCS.Mark (203) END
  368.         ELSE
  369.           OCI.Load (x);
  370.           IF OCS.pragma [OCS.rangeChk] THEN
  371.             OCC.GetDReg (y, NIL); OCC.Move (W, x, y); OCI.EXT (L, y.a0);
  372.             OCI.CMP (L, x, y); OCC.TrapCC (OCC.RangeCheck, OCC.NE);
  373.           END
  374.         END;
  375.         x.typ := OCT.inttyp
  376.       ELSIF f = Int THEN
  377.         IF x.mode = Con THEN
  378.           OCE.SetIntType (x); IF x.typ.form # SInt THEN OCS.Mark (203) END
  379.         ELSE
  380.           OCI.Load (x);
  381.           IF OCS.pragma [OCS.rangeChk] THEN
  382.             OCC.GetDReg (y, NIL); OCC.Move (B, x, y); OCI.EXT (W, y.a0);
  383.             OCI.CMP (W, x, y); OCC.TrapCC (OCC.RangeCheck, OCC.NE);
  384.           END
  385.         END;
  386.         x.typ := OCT.sinttyp
  387.       ELSIF f = Set THEN
  388.         IF OCS.option [OCS.standard] THEN OCS.Mark (915) END;
  389.         IF x.mode = Con THEN
  390.           s := SYS.VAL (SET, x.a0);
  391.           IF (s - {0..15}) # {} THEN OCS.Mark (203) END;
  392.         ELSE
  393.           OCI.Load (x);
  394.           IF OCS.pragma [OCS.rangeChk] THEN
  395.             y.mode := Con; y.a0 := 0; y.typ := OCT.linttyp;
  396.             OCI.Load (y); OCC.Move (W, x, y);
  397.             OCI.CMP (L, x, y); OCC.TrapCC (OCC.RangeCheck, OCC.NE);
  398.           END
  399.         END;
  400.         x.typ := OCT.wsettyp
  401.       ELSIF f = WSet THEN
  402.         IF OCS.option [OCS.standard] THEN OCS.Mark (915) END;
  403.         IF x.mode = Con THEN
  404.           s := SYS.VAL (SET, x.a0);
  405.           IF (s - {0..7}) # {} THEN OCS.Mark (203) END;
  406.         ELSE
  407.           OCI.Load (x);
  408.           IF OCS.pragma [OCS.rangeChk] THEN
  409.             y.mode := Con; y.a0 := 0; y.typ := OCT.linttyp;
  410.             OCI.Load (y); OCC.Move (B, x, y);
  411.             OCI.CMP (W, x, y); OCC.TrapCC (OCC.RangeCheck, OCC.NE)
  412.           END
  413.         END;
  414.         x.typ := OCT.bsettyp
  415.       ELSIF f = LReal THEN
  416.         x.typ := OCT.realtyp
  417.       ELSE
  418.         OCS.Mark (111)
  419.       END
  420.     |
  421.     OCT.pADR :
  422.       OCI.Adr (x); x.typ := OCT.adrtyp
  423.     |
  424.     OCT.pCC :
  425.       IF (f = SInt) & (x.mode = Con) THEN
  426.         IF (x.a0 >= 0) & (x.a0 < 16) THEN OCE.setCC (x, x.a0)
  427.         ELSE OCS.Mark (219)
  428.         END
  429.       ELSE OCS.Mark (17)
  430.       END
  431.     |
  432.     OCT.pDISPOSE :
  433.       IF f IN ptrSet THEN
  434.         IF x.rdOnly THEN OCS.Mark (324) END;
  435.         IF x.typ.sysflg = BCPLFlag THEN
  436.           y := x; OCI.Load (y);
  437.           OCC.PutF5 (OCC.ADD, L, y, y);               (* ADD.L  Dm, Dm  *)
  438.           OCC.PutF5 (OCC.ADD, L, y, y);               (* ADD.L  Dm, Dm  *)
  439.           OCC.Move (L, y, x); OCI.Unload (y)
  440.         END;
  441.         y.mode := Push; y.a0 := SP;
  442.         OCC.ForgetObj (x.obj);
  443.         IF x.mode IN {Ind, IndX} THEN OCI.MoveAdr (x, y)
  444.         ELSE OCC.PutF3 (OCC.PEA, x)
  445.         END;
  446.         OCI.Unload (x);
  447.         OCC.CallKernel (OCC.kDispose);
  448.         z.mode := Undef; OCC.ForgetRegs; OCC.RestoreRegisters (R, z)
  449.       ELSE
  450.         OCS.Mark (111)
  451.       END;
  452.       x.typ := OCT.notyp
  453.     |
  454.     OCT.pSIZE :
  455.       IF x.mode = Typ THEN x.a0 := x.typ.size
  456.       ELSE OCS.Mark (110); x.a0 := 1
  457.       END;
  458.       x.mode := Con; OCE.SetIntType (x)
  459.     |
  460.     OCT.pSTRLEN :
  461.       IF ((f = Array) OR (f = DynArr)) & (x.typ.BaseTyp.form = Char) THEN
  462.         y := x; OCI.LoadAdr (y); y.mode := Pop;       (*    LEA    <y>,Ay *)
  463.         OCC.ForgetReg (y.a0);
  464.         x.mode := Con; x.a0 := 0; x.typ := OCT.linttyp;
  465.         OCI.Load (x);                                 (*    MOVEQ  #0,Dx  *)
  466.         OCC.PutF1 (OCC.TST, B, y); OCC.FreeReg (y);   (* 1$ TST.B  (Ay)+  *)
  467.         OCC.PutWord (6704H);                          (*    BEQ    2$     *)
  468.         OCC.PutF7 (OCC.ADDQ, L, 1, x);                (*    ADDQ.L #1,Dx  *)
  469.         OCC.PutWord (60F8H);                          (*    BRA    1$     *)
  470.       ELSIF f = String THEN                           (* 2$               *)
  471.         x.mode := Con; x.a0 := x.a1 - 1; x.typ := OCT.linttyp
  472.       ELSE
  473.         OCS.Mark (111)
  474.       END
  475.     |
  476.     OCT.pASH :
  477.       IF f IN intSet THEN
  478.         OCI.Load (x); IF f # LInt THEN OCE.ConvertInts (x, OCT.linttyp) END
  479.       ELSE
  480.         OCS.Mark (111)
  481.       END
  482.     |
  483.     OCT.pASSERT :
  484.       IF f = Bool THEN
  485.         IF x.mode = Con THEN
  486.           IF x.a0 = 0 THEN OCS.Mark (319) ELSE OCS.Mark (320) END;
  487.           OCE.setCC (x, OCC.T)
  488.         END;
  489.       ELSE OCS.Mark (120)
  490.       END
  491.     |
  492.     OCT.pCOPY :
  493.       IF
  494.         ~((((f = Array) OR (f = DynArr)) & (x.typ.BaseTyp.form = Char))
  495.           OR (f = String))
  496.       THEN
  497.         OCS.Mark (111)
  498.       END
  499.     |
  500.     OCT.pDEC, OCT.pINC :
  501.       IF x.mode >= Con THEN     OCS.Mark (112)
  502.       ELSIF ~(f IN intSet) THEN OCS.Mark (111)
  503.       ELSIF x.rdOnly THEN OCS.Mark (324)
  504.       END
  505.     |
  506.     OCT.pINCL, OCT.pEXCL :
  507.       IF x.mode >= Con THEN     OCS.Mark (112)
  508.       ELSIF ~(f IN setSet) THEN OCS.Mark (111); x.typ := OCT.settyp
  509.       ELSIF x.rdOnly THEN OCS.Mark (324)
  510.       END
  511.     |
  512.     OCT.pLEN :
  513.       IF (f # DynArr) & (f # Array) THEN OCS.Mark (131) END
  514.     |
  515.     OCT.pAND, OCT.pOR, OCT.pXOR :
  516.       IF ~(f IN bitOpSet) THEN OCS.Mark (111) END
  517.     |
  518.     OCT.pBIT, OCT.pGET, OCT.pPUT :
  519.       IF (f IN intSet) & (x.mode = Con) THEN
  520.         x.mode := Abs; x.obj := NIL
  521.       ELSIF f IN adrSet THEN
  522.         IF x.mode = Var THEN
  523.           x.mode := Ind; x.a1 := 0
  524.         ELSE
  525.           OCC.GetAReg (y, NIL); x.obj := NIL; OCC.Move (L, x, y);
  526.           x := y; x.mode := RegI; x.a1 := 0
  527.         END
  528.       ELSE
  529.         OCS.Mark (111)
  530.       END
  531.     |
  532.     OCT.pGETREG, OCT.pPUTREG, OCT.pREG :
  533.       IF (f IN intSet) & (x.mode = Con) THEN
  534.         IF (0 <= x.a0) & (x.a0 <= 15) THEN
  535.           x.mode := Reg;
  536.           IF fctno = OCT.pREG THEN
  537.             OCC.ReserveReg (x.a0, NIL); x.typ := OCT.lwordtyp
  538.           END
  539.         ELSE OCS.Mark (219)
  540.         END
  541.       ELSE
  542.         OCS.Mark (17)
  543.       END
  544.     |
  545.     OCT.pLSH, OCT.pROT :
  546.       IF (f = String) & (x.a1 <= 2) THEN
  547.         x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  548.       END;
  549.       IF f IN bitOpSet THEN OCI.Load (x)
  550.       ELSE OCS.Mark (111)
  551.       END
  552.     |
  553.     OCT.pSYSNEW :
  554.       IF ~(f IN ptrSet) OR (x.mode = Con) THEN OCS.Mark (111)
  555.       ELSIF x.rdOnly THEN OCS.Mark (324)
  556.       ELSIF NeedsTag (x.typ) THEN OCS.Mark (339)
  557.       ELSE y.mode := Undef; OCC.SaveRegisters (R, y, OCC.AllRegs)
  558.       END
  559.     |
  560.     OCT.pVAL : IF x.mode # Typ THEN OCS.Mark (110) END
  561.     |
  562.     OCT.pMOVE :
  563.       IF (f IN adrSet) THEN
  564.         y.mode := Push; y.a0 := SP;
  565.         OCC.Move (L, x, y); OCI.Unload (x);
  566.       ELSE
  567.         OCS.Mark (111)
  568.       END
  569.     |
  570.     OCT.pTAG :
  571.       typ := x.typ; f1 := typ.sysflg;
  572.       IF f = Pointer THEN typ := typ.BaseTyp END;
  573.       IF (typ.form = Record) & (f1 = OberonFlag) THEN
  574.         IF x.mode = Typ THEN (* Type *)
  575.           x.mode := Con; x.a0 := 0; x.a1 := 0; x.typ := OCT.tagtyp;
  576.           x.label := typ.label;
  577.           OCI.Adr (x)
  578.         ELSIF (x.mode <= RegX) & (f = Pointer) THEN (* Pointer variable *)
  579.           GetTag (x)
  580.         ELSIF (x.mode = Ind) & (x.obj # NIL) & (x.obj # OCC.wasderef) THEN
  581.           (* VAR parameter *)
  582.           x.mode := Var; x.obj := NIL; INC (x.a0, 4)
  583.         ELSE (* Bzzzzt! *)
  584.           OCS.Mark (338)
  585.         END
  586.       ELSIF f = PtrTyp THEN
  587.         IF (x.mode <= RegX) THEN (* Pointer variable *)
  588.           GetTag (x)
  589.         ELSE (* Bzzzzt! *)
  590.           OCS.Mark (338)
  591.         END
  592.       ELSE
  593.         OCS.Mark (338)
  594.       END;
  595.       x.typ := OCT.tagtyp; x.rdOnly := FALSE
  596.     |
  597.   ELSE
  598.     OCS.Mark (1014); OCS.Mark (fctno)
  599.   END; (* CASE fctno *)
  600. END StPar1;
  601.  
  602. (*------------------------------------*)
  603. PROCEDURE StPar2 *
  604.   ( VAR par1, par2 : OCT.Item; fctno : INTEGER; VAR R : OCC.RegState );
  605.  
  606.   VAR f, dim : INTEGER; L0, L1, op : LONGINT; typ, btyp, t1 : OCT.Struct;
  607.       freePar2 : BOOLEAN; x, y, r0, r1 : OCT.Item;
  608.       dsc : OCT.Desc;
  609.  
  610. BEGIN (* StPar2 *)
  611.   f := par2.typ.form; freePar2 := FALSE;
  612.   IF fctno < OCT.TwoPar THEN OCS.Mark (64); RETURN END;
  613.   CASE fctno OF
  614.     OCT.pASH, OCT.pLSH, OCT.pROT :
  615.       IF
  616.         ((fctno = OCT.pASH) & (f IN intSet)) OR
  617.         ((fctno # OCT.pASH) & (f IN bitOpSet))
  618.       THEN
  619.         IF (par2.mode = Con) & (par2.a0 = 0) THEN RETURN END;
  620.         IF fctno = OCT.pASH THEN op := OCC.ASR
  621.         ELSIF fctno = OCT.pLSH THEN op := OCC.LSR
  622.         ELSE op := OCC.ROR
  623.         END;
  624.         IF par2.mode = Con THEN
  625.           IF par2.a0 < 0 THEN par2.a0 := -par2.a0 ELSE INC (op, 100H) END;
  626.           IF par2.a0 > 8 THEN OCI.Load (par2); freePar2 := TRUE END;
  627.           OCC.Shift (op, par1.typ.size, par2, par1);
  628.           IF freePar2 THEN OCC.FreeReg (par2) END
  629.         ELSE
  630.           OCI.Load (par2);                         (*    MOVE.L <par2>,Dn *)
  631.           OCC.PutF1 (OCC.TST, par2.typ.size, par2);(*    TST.?  Dn        *)
  632.           L0 := OCC.pc; OCC.PutWord (6A00H);       (*    BPL.S  1$        *)
  633.           OCC.PutF1 (OCC.NEG, par2.typ.size, par2);(*    NEG.?  Dn        *)
  634.           OCC.Shift (op, par1.typ.size, par2, par1);
  635.                                                    (*    opR.?  Dn,<par1> *)
  636.           L1 := OCC.pc; OCC.PutWord (6000H);       (*    BRA.S  $2        *)
  637.           OCC.PatchWord (L0, OCC.pc - L0 - 2);
  638.           OCC.Shift (op+100H, par1.typ.size, par2, par1);
  639.                                                    (* 1$ opL.?  Dn,<par1> *)
  640.           OCC.PatchWord (L1, OCC.pc - L1 - 2);     (* 2$                  *)
  641.         END
  642.       ELSE
  643.         OCS.Mark (111)
  644.       END
  645.     |
  646.     OCT.pASSERT :
  647.       IF (par2.mode = Con) & (f IN intSet) THEN
  648.         IF par1.mode # Coc THEN
  649.           OCC.PutF1 (OCC.TST, B, par1);          (*    TST.B  <par1>      *)
  650.           OCI.Unload (par1); L0 := OCC.pc;
  651.           OCC.PutWord (OCC.BNE)                  (*    BNE.S  2$          *)
  652.         ELSE
  653.           op := OCC.Bcc + (par1.a0 * 100H);
  654.           OCC.PutWord (op);
  655.           OCC.PutWord (par1.a1);                 (*    Bcc    2$          *)
  656.           L0 := OCC.pc - 2; OCC.FixLink (par1.a2);
  657.         END;
  658.         r0.mode := Reg; r0.a0 := D0;
  659.         OCC.Move (L, par2, r0);               (* 1$ MOVE.L #par2,D0      *)
  660.         OCI.Unload (par2);
  661.         x.mode := Con; x.a0 := 0; x.typ := OCT.stringtyp;
  662.         x.label := OCT.ConstLabel;
  663.         OCC.PutF2 (OCC.LEA, x, A0);           (*    LEA    ModuleName,A0 *)
  664.         x.a0 := (OCS.line * 10000H) + OCS.col; x.typ := OCT.linttyp;
  665.         r1.mode := Reg; r1.a0 := D1;
  666.         OCC.Move (L, x, r1);                  (*    MOVE.L pos,D1        *)
  667.         OCC.CallKernel (OCC.kHalt);           (*    JSR    Kernel.Halt   *)
  668.         OCC.ForgetRegs;
  669.         IF par1.mode # Coc THEN               (* 2$                      *)
  670.           OCC.PatchWord (L0, OCC.pc - L0 - 2)
  671.         ELSE OCC.FixLink (L0)
  672.         END;
  673.       ELSE OCS.Mark (17)
  674.       END;
  675.       par1.typ := OCT.notyp
  676.     |
  677.     OCT.pDEC, OCT.pINC :
  678.       IF par1.typ # par2.typ THEN
  679.         IF (par1.typ.form = Int) & (f = SInt) THEN
  680.           OCE.ConvertInts (par2, OCT.inttyp)
  681.         ELSIF (par1.typ.form = LInt) & (f IN {SInt, Int}) THEN
  682.           OCE.ConvertInts (par2, OCT.linttyp)
  683.         ELSE OCS.Mark (111)
  684.         END
  685.       ELSIF par2.mode # Con THEN
  686.         OCI.Load (par2)
  687.       END;
  688.       IF fctno = OCT.pDEC THEN op := OCC.SUB ELSE op := OCC.ADD END;
  689.       OCC.PutF5 (op, par1.typ.size, par2, par1);
  690.       IF OCS.pragma [OCS.ovflChk] THEN OCC.Trap (OCC.OverflowCheck) END;
  691.       par1.typ := OCT.notyp
  692.     |
  693.     OCT.pEXCL :
  694.       OCE.Set0 (x, par2);
  695.       IF x.mode = Con THEN
  696.         x.a0 := SYS.VAL (LONGINT, allSet - SYS.VAL (SET, x.a0));
  697.         OCC.PutF6 (OCC.ANDI, par1.typ.size, x, par1)
  698.       ELSE
  699.         OCC.PutF1 (OCC.NOT, L, x);
  700.         OCC.PutF5 (OCC.AND, par1.typ.size, x, par1)
  701.       END;
  702.       par1.typ := OCT.notyp
  703.     |
  704.     OCT.pINCL :
  705.       OCE.Set0 (x, par2);
  706.       IF x.mode = Con THEN OCC.PutF6 (OCC.ORI, par1.typ.size, x, par1)
  707.       ELSE OCC.PutF5 (OCC.iOR, par1.typ.size, x, par1)
  708.       END;
  709.       par1.typ := OCT.notyp
  710.     |
  711.     OCT.pLEN :
  712.       IF (par2.mode = Con) & (f = SInt) THEN
  713.         dim := SHORT (par2.a0); typ := par1.typ;
  714.         WHILE (dim > 0) & (typ.form IN {DynArr, Array}) DO
  715.           typ := typ.BaseTyp; DEC (dim)
  716.         END;
  717.         IF (dim # 0) OR ~(typ.form IN {DynArr, Array}) THEN OCS.Mark (132)
  718.         ELSE
  719.           IF typ.form = DynArr THEN OCI.DescItem (par1, par1.desc, typ.adr)
  720.           ELSE par1.mode := Con; par1.a0 := typ.n
  721.           END;
  722.           par1.typ := OCT.linttyp
  723.         END
  724.       ELSE
  725.         OCS.Mark (111)
  726.       END
  727.     |
  728.     OCT.pAND, OCT.pOR, OCT.pXOR :
  729.       IF f IN bitOpSet THEN
  730.         IF (par1.mode = Con) & (par2.mode = Con) THEN
  731.           IF fctno = OCT.pAND THEN
  732.             par1.a0 := SYS.AND (par1.a0, par2.a0)
  733.           ELSIF fctno = OCT.pXOR THEN
  734.             par1.a0 := SYS.XOR (par1.a0, par2.a0)
  735.           ELSE
  736.             par1.a0 := SYS.LOR (par1.a0, par2.a0)
  737.           END;
  738.           IF f IN intSet THEN OCE.SetIntType (par1) END
  739.         ELSE
  740.           IF fctno = OCT.pAND THEN op := OCC.AND
  741.           ELSIF fctno = OCT.pXOR THEN op := OCC.EOR
  742.           ELSE op := OCC.iOR
  743.           END;
  744.           IF par1.mode = Con THEN
  745.             IF par1.typ.form # par2.typ.form THEN par1.typ := par2.typ END;
  746.             OCI.Load (par2); OCC.PutF5 (op, par2.typ.size, par1, par2);
  747.             par1 := par2
  748.           ELSIF par2.mode = Con THEN
  749.             IF par2.typ.form # par1.typ.form THEN par2.typ := par1.typ END;
  750.             OCI.Load (par1); OCC.PutF5 (op, par1.typ.size, par2, par1)
  751.           ELSE
  752.             IF par1.typ.form = par2.typ.form THEN
  753.               OCI.Load (par1); IF op = OCC.EOR THEN OCI.Load (par2) END;
  754.               OCC.PutF5 (op, par1.typ.size, par2, par1); OCI.Unload (par2)
  755.             ELSE
  756.               OCS.Mark (100)
  757.             END
  758.           END
  759.         END
  760.       ELSE
  761.         OCS.Mark (111)
  762.       END
  763.     |
  764.     OCT.pBIT :
  765.       IF f IN intSet THEN
  766.         IF (par2.mode = Con) & (par2.a0 >= 8) THEN OCI.Load (par1)
  767.         ELSIF (par2.mode # Con) THEN OCI.Load (par1); OCI.Load (par2)
  768.         END;
  769.         OCC.Bit (OCC.BTST, par2, par1); OCI.Unload (par1); OCI.Unload (par2)
  770.       ELSE
  771.         OCS.Mark (111)
  772.       END;
  773.       OCE.setCC (par1, OCC.NE)
  774.     |
  775.     OCT.pGET, OCT.pGETREG :
  776.       IF par2.mode >= Con THEN OCS.Mark (112)
  777.       ELSIF ~(f IN realSet) THEN
  778.         IF par2.rdOnly THEN OCS.Mark (324) END;
  779.         OCC.Move (par2.typ.size, par1, par2);
  780.         OCC.ForgetObj (par2.obj)
  781.       ELSE OCS.Mark (111)
  782.       END;
  783.       par1.typ := OCT.notyp
  784.     |
  785.     OCT.pPUT, OCT.pPUTREG :
  786.       IF par2.mode IN {XProc, LProc} THEN OCI.MoveAdr (par2, par1)
  787.       ELSIF f IN putSet THEN OCC.Move (par2.typ.size, par2, par1)
  788.       ELSE OCS.Mark (111)
  789.       END;
  790.       par1.typ := OCT.notyp
  791.     |
  792.     OCT.pSYSNEW :
  793.       x.mode := Push; x.a0 := SP;
  794.       IF par2.typ.form # LInt THEN OCE.ConvertInts (par2, OCT.linttyp) END;
  795.       OCC.Move (L, par2, x); OCI.Unload (par2)
  796.     |
  797.     OCT.pVAL : par2.typ := par1.typ; par1 := par2
  798.     |
  799.     OCT.pCOPY :
  800.       IF
  801.         ((f = Array) OR (f = DynArr)) & (par2.typ.BaseTyp.form = Char)
  802.       THEN
  803.         IF par2.rdOnly THEN OCS.Mark (324) END;
  804.         IF f = Array THEN
  805.           x.mode := Con; x.a0 := par2.typ.n;
  806.           IF (par1.typ.form = String) & (par1.a1 < x.a0) THEN
  807.             x.a0 := par1.a1
  808.           ELSIF (par1.typ.form = Array) & (par1.typ.n < x.a0) THEN
  809.             x.a0 := par1.typ.n
  810.           END;
  811.           DEC (x.a0); OCE.SetIntType (x)
  812.         ELSE
  813.           IF (par1.typ.form = String) & (par1.a1 = 1) THEN
  814.             x.mode := Con; x.a0 := 0; x.typ := OCT.sinttyp
  815.           ELSE OCI.DescItem (x, par2.desc, par2.typ.adr)
  816.           END
  817.         END;
  818.         OCI.CopyString (par1, par2, x)
  819.       ELSE
  820.         OCS.Mark (111)
  821.       END;
  822.       par1.typ := OCT.notyp
  823.     |
  824.     OCT.pMOVE :
  825.       IF (f IN adrSet) THEN
  826.         x.mode := Push; x.a0 := SP;
  827.         OCC.Move (L, par2, x); OCI.Unload (par2)
  828.       ELSE
  829.         OCS.Mark (111)
  830.       END
  831.     |
  832.   ELSE
  833.     OCS.Mark (1015); OCS.Mark (fctno)
  834.   END; (* CASE fctno *)
  835. END StPar2;
  836.  
  837. (*------------------------------------*)
  838. PROCEDURE StPar3 *
  839.   ( VAR p, x : OCT.Item; fctno : INTEGER; VAR R : OCC.RegState );
  840.  
  841.   VAR f : INTEGER; y : OCT.Item;
  842.  
  843. BEGIN (* StPar3 *)
  844.   f := x.typ.form;
  845.   IF fctno = OCT.pMOVE THEN
  846.     IF f IN intSet THEN
  847.       IF f # LInt THEN OCE.ConvertInts (x, OCT.linttyp) END;
  848.       y.mode := Push; y.a0 := SP;
  849.       OCC.Move (L, x, y); OCI.Unload (x);
  850.       OCC.CallKernel (OCC.kMove); OCC.ForgetRegs;
  851.       y.mode := Undef; OCC.RestoreRegisters (R, y)
  852.     ELSE
  853.       OCS.Mark (111)
  854.     END;
  855.     p.typ := OCT.notyp
  856.   ELSE
  857.     OCS.Mark (64)
  858.   END
  859. END StPar3;
  860.  
  861. (*------------------------------------*)
  862. PROCEDURE StFct *
  863.   ( VAR p : OCT.Item; fctno, parno : INTEGER; VAR R : OCC.RegState );
  864.  
  865.   VAR
  866.     p2, r0, r1, x, y : OCT.Item; L0 : LONGINT; f, f1, proc : INTEGER;
  867.     btyp : OCT.Struct;
  868.  
  869. BEGIN (* StFct *)
  870.   IF fctno >= OCT.TwoPar THEN
  871.     IF (fctno = OCT.pASSERT) & (parno = 1) THEN
  872.       IF p.mode # Coc THEN
  873.         OCC.PutF1 (OCC.TST, B, p);                    (*    TST.B <p>     *)
  874.         OCI.Unload (p); L0 := OCC.pc;
  875.         OCC.PutWord (OCC.BNE)                         (*    BNE.S 2$      *)
  876.       ELSE
  877.         OCC.PutWord (OCC.Bcc + (p.a0 * 100H));
  878.         OCC.PutWord (p.a1);                           (*    Bcc   2$      *)
  879.         L0 := OCC.pc - 2; OCC.FixLink (p.a2);
  880.       END;
  881.       p2.mode := Con; p2.a0 := 20; p2.typ := OCT.linttyp;
  882.       r0.mode := Reg; r0.a0 := D0;
  883.       OCC.Move (L, p2, r0); OCI.Unload (p2);  (* 1$ MOVE.L #20,D0        *)
  884.       x.mode := Con; x.a0 := 0; x.typ := OCT.stringtyp;
  885.       x.label := OCT.ConstLabel;
  886.       OCC.PutF2 (OCC.LEA, x, A0);             (*    LEA    ModuleName,A0 *)
  887.       x.a0 := (OCS.line * 10000H) + OCS.col; x.typ := OCT.linttyp;
  888.       r1.mode := Reg; r1.a0 := D1;
  889.       OCC.Move (L, x, r1);                    (*    MOVE.L pos,D1        *)
  890.       OCC.CallKernel (OCC.kHalt);             (*    JSR    Kernel.Halt   *)
  891.       OCC.ForgetRegs;
  892.       IF p.mode # Coc THEN                    (* 2$                      *)
  893.         OCC.PatchWord (L0, OCC.pc - L0 - 2)
  894.       ELSE OCC.FixLink (L0)
  895.       END;
  896.       p.typ := OCT.notyp
  897.     ELSIF (fctno = OCT.pDEC) & (parno = 1) THEN
  898.       IF p.rdOnly THEN OCS.Mark (324) END;
  899.       p2.mode := Con; p2.a0 := 1; p2.typ := p.typ;
  900.       OCC.PutF5 (OCC.SUB, p.typ.size, p2, p);
  901.       IF OCS.pragma [OCS.ovflChk] THEN OCC.Trap (OCC.OverflowCheck) END;
  902.       p.typ := OCT.notyp
  903.     ELSIF (fctno = OCT.pINC) & (parno = 1) THEN
  904.       IF p.rdOnly THEN OCS.Mark (324) END;
  905.       p2.mode := Con; p2.a0 := 1; p2.typ := p.typ;
  906.       OCC.PutF5 (OCC.ADD, p.typ.size, p2, p);
  907.       IF OCS.pragma [OCS.ovflChk] THEN OCC.Trap (OCC.OverflowCheck) END;
  908.       p.typ := OCT.notyp
  909.     ELSIF (fctno = OCT.pLEN) & (parno = 1) THEN
  910.       IF p.typ.form = DynArr THEN OCI.DescItem (p, p.desc, p.typ.adr)
  911.       ELSE p.mode := Con; p.a0 := p.typ.n; p.typ := OCT.linttyp
  912.       END
  913.     ELSIF fctno = OCT.pINLINE THEN
  914.       p.typ := OCT.notyp
  915.     ELSIF fctno = OCT.pSYSNEW THEN
  916.       IF
  917.         ((p.typ.form = Pointer) & (p.typ.sysflg = OberonFlag))
  918.         OR (p.typ.form = PtrTyp)
  919.       THEN
  920.         OCC.PutWord (50E7H)                           (* ST     -(A7)     *)
  921.       ELSE
  922.         OCC.PutWord (51E7H)                           (* SF     -(A7)     *)
  923.       END;
  924.       OCC.CallKernel (OCC.kNewSysBlk);                (* JSR    NewSysBlk *)
  925.       IF p.typ.sysflg = BCPLFlag THEN
  926.         OCC.PutWord (0E480H)                          (* ASR.L  #2,D0     *)
  927.       END;
  928.       x.mode := Undef; OCC.ForgetRegs; OCC.RestoreRegisters (R, x);
  929.       r0.mode := Reg; r0.a0 := D0;
  930.       OCC.Move (L, r0, p);                            (* MOVE.L D0,<var>  *)
  931.       OCC.ForgetObj (p.obj); p.typ := OCT.notyp
  932.     ELSIF (parno < 2) OR (fctno = OCT.pMOVE) & (parno < 3) THEN
  933.       OCS.Mark (65)
  934.     END
  935.   ELSIF (fctno = OCT.pNEW) & (parno >= 1) THEN
  936.     f := p.typ.form;
  937.     IF f = Pointer THEN
  938.       f1 := p.typ.sysflg; btyp := p.typ.BaseTyp; f := btyp.form;
  939.       r0.mode := Reg; r0.a0 := D0;
  940.       IF (f1 = OberonFlag) & NeedsTag (btyp) THEN
  941.         IF f = Record THEN
  942.           IF parno > 1 THEN OCS.Mark (64) END;
  943.           proc := OCC.kNewRecord
  944.         ELSIF f = Array THEN
  945.           IF parno > 1 THEN OCS.Mark (64) END;
  946.           proc := OCC.kNewArray
  947.         ELSIF f = DynArr THEN
  948.           WHILE btyp.form = DynArr DO btyp := btyp.BaseTyp; DEC (parno) END;
  949.           WHILE btyp.form = Array DO btyp := btyp.BaseTyp END;
  950.           IF parno > 1 THEN OCS.Mark (64)
  951.           ELSIF parno < 1 THEN OCS.Mark (65)
  952.           END;
  953.           proc := OCC.kNewArray
  954.         END
  955.       ELSE
  956.         IF f1 = OberonFlag THEN
  957.           IF f = DynArr THEN
  958.             WHILE btyp.form = DynArr DO
  959.               btyp := btyp.BaseTyp; DEC (parno)
  960.             END;
  961.             IF parno > 1 THEN OCS.Mark (64)
  962.             ELSIF parno < 1 THEN OCS.Mark (65)
  963.             END
  964.           END;
  965.           OCC.PutWord (50E7H)                     (* ST     -(A7)        *)
  966.         ELSE
  967.           OCC.PutWord (51E7H)                     (* SF     -(A7)        *)
  968.         END;
  969.         proc := OCC.kNewSysBlk
  970.       END;
  971.       OCC.CallKernel (proc);
  972.       IF f1 = BCPLFlag THEN OCC.PutWord (0E480H) END;(* ASR.L  #2,D0     *)
  973.       x.mode := Undef; OCC.ForgetRegs; OCC.RestoreRegisters (R, x);
  974.       OCC.Move (L, r0, p);                           (* MOVE.L D0,<var>  *)
  975.       OCC.ForgetObj (p.obj)
  976.     END;
  977.     p.typ := OCT.notyp
  978.   ELSIF parno < 1 THEN
  979.     OCS.Mark (65)
  980.   END
  981. END StFct;
  982.  
  983. (*------------------------------------*)
  984. PROCEDURE Inline * (VAR x : OCT.Item);
  985.  
  986.   VAR f : INTEGER;
  987.  
  988. BEGIN (* Inline *)
  989.   f := x.typ.form;
  990.   IF (f IN intSet) & (x.mode = Con) THEN
  991.     IF f = LInt THEN OCC.PutLong (x.a0)
  992.     ELSE OCC.PutWord (x.a0)
  993.     END
  994.   ELSE
  995.     OCS.Mark (17)
  996.   END
  997. END Inline;
  998.  
  999. (*------------------------------------*)
  1000. PROCEDURE NewPar * (VAR x, p0, p1 : OCT.Item; n : INTEGER);
  1001.  
  1002.   VAR f, i : INTEGER; btyp : OCT.Struct; desc, r0, y : OCT.Item;
  1003.       calcSize : BOOLEAN;
  1004.  
  1005. BEGIN (* NewPar *)
  1006.   IF p1.typ.form IN intSet THEN
  1007.     f := x.typ.form;
  1008.     IF (f = Pointer) & (x.typ.sysflg = OberonFlag) THEN
  1009.       btyp := x.typ; i := 0;
  1010.       WHILE (btyp.BaseTyp # NIL) & (i < n) DO
  1011.         btyp := btyp.BaseTyp; INC (i)
  1012.       END;
  1013.       f := btyp.form;
  1014.       IF f = DynArr THEN
  1015.         IF p1.typ.form # LInt THEN OCE.ConvertInts (p1, OCT.linttyp) END;
  1016.         OCI.DescItem (desc, x.desc, btyp.adr);
  1017.         OCC.Move (L, p1, desc);
  1018.         OCI.UpdateDesc (desc, btyp.adr);
  1019.         btyp := btyp.BaseTyp; f := btyp.form;
  1020.         IF p1.mode = Con THEN
  1021.           IF f # DynArr THEN p1.a0 := p1.a0 * btyp.size END;
  1022.           calcSize := FALSE
  1023.         ELSE
  1024.           calcSize := TRUE
  1025.         END;
  1026.         IF n = 1 THEN p0 := p1
  1027.         ELSE OCE.Op (OCS.times, p0, p1, TRUE)
  1028.         END;
  1029.         IF calcSize & (f # DynArr) & (btyp.size > 1) THEN
  1030.           y.mode := Con; y.a0 := btyp.size; y.typ := OCT.linttyp;
  1031.           OCE.Op (OCS.times, p0, y, TRUE)
  1032.         END;
  1033.         IF f # DynArr THEN
  1034.           OCI.UnloadDesc (x);
  1035.           y.mode := Push; y.a0 := SP;
  1036.           OCC.Move (L, p0, y); OCI.Unload (p0)
  1037.         END;
  1038.       ELSE OCS.Mark (64)
  1039.       END
  1040.     ELSE OCS.Mark (64)
  1041.     END
  1042.   ELSE OCS.Mark (328)
  1043.   END
  1044. END NewPar;
  1045.  
  1046. END OCP.
  1047.  
  1048. (***************************************************************************
  1049.  
  1050.   $Log: OCP.mod $
  1051.   Revision 5.16  1995/06/29  19:10:59  fjc
  1052.   - Removed code that was second-guessing the garbage collector
  1053.  
  1054.   Revision 5.15  1995/06/02  18:41:18  fjc
  1055.   - Various changes to implement the SMALLDATA and RESIDENT
  1056.     options.
  1057.   - Now uses OCI.CMP.
  1058.  
  1059.   Revision 5.14  1995/05/13  23:08:42  fjc
  1060.   - Changed INTEGER to LONGINT where necessary.
  1061.  
  1062.   Revision 5.13  1995/05/08  17:07:09  fjc
  1063.   - OCI.IsParam() --> OCT.IsParam().
  1064.  
  1065.   Revision 5.11  1995/03/09  19:10:56  fjc
  1066.   - Incorporated changes from 5.22.
  1067.  
  1068.   Revision 5.10  1995/02/27  17:05:20  fjc
  1069.   - Removed tracing code.
  1070.   - Changed to use new register handling procedures.
  1071.  
  1072.   Revision 5.9.1.1  1995/03/08  19:20:29  fjc
  1073.   - OC 5.22
  1074.  
  1075.   Revision 5.9  1995/01/26  00:17:17  fjc
  1076.   - Release 1.5
  1077.  
  1078.   Revision 5.8  1995/01/03  21:22:07  fjc
  1079.   - Changed OCG to OCM.
  1080.  
  1081.   Revision 5.7  1994/12/16  17:33:01  fjc
  1082.   - Changed Symbol to Label.
  1083.  
  1084.   Revision 5.6  1994/11/13  11:31:33  fjc
  1085.   - Changed handling of ENTIER.
  1086.   - [bug] ABS now implemented for reals.
  1087.   - Implemented SYSTEM.CC.
  1088.  
  1089.   Revision 5.5  1994/10/23  16:16:31  fjc
  1090.   - Complete overhaul:
  1091.     - Added SaveRegs().
  1092.     - Removed code for handling obsolete SYSTEM procedures:
  1093.       GC, RC, ARGLEN, ARGS, SIZETAG, SETCLEANUP, BIND,
  1094.       GETNAME and NEWTAG.
  1095.     - All access to RTS is now through OCC.CallKernel().
  1096.  
  1097.   Revision 5.4  1994/09/25  18:01:55  fjc
  1098.   - Changed to reflect new object modes and system flags.
  1099.  
  1100.   Revision 5.3  1994/09/15  10:36:36  fjc
  1101.   - Replaced switches with pragmas.
  1102.  
  1103.   Revision 5.2  1994/09/08  10:50:49  fjc
  1104.   - Changed to use pragmas/options.
  1105.  
  1106.   Revision 5.1  1994/09/03  19:29:08  fjc
  1107.   - Bumped version number
  1108.  
  1109. ***************************************************************************)
  1110.